VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ImageDC"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'====================================================================================
'MemoryDC - Store an image in a Device Context bitmap
'====================================================================================
'NOTE: Please be careful when editing this page. This same class is used both in
'      the game and the level editor.
Option Explicit

'Thanks to the unkown programmer of vbAccelerator who created the original of this,
'you didn't leave any contact of any kind anywhere in your sample app :P

'Bitmap parameters definition -------------------------------------------------------
Private Type Bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Long
    bmBitsPixel As Integer
    bmBits As Long
End Type

'API Declarations -------------------------------------------------------------------
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function GetDC& Lib "user32" (ByVal hWnd As Long)
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawTransparent Lib "msimg32.dll" Alias "TransparentBlt" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long

'Class Variables --------------------------------------------------------------------
Public ChromaColour As Long
Private m_hDC As Long
Private m_hBMP As Long
Private m_hBmpOld As Long
Private m_lWidth As Long
Private m_lHeight As Long

'GET Width: Return the width of the image
'====================================================================================
Public Property Get Width() As Long
   Width = m_lWidth
End Property

'LET Width: Set Width of image
'====================================================================================
Public Property Let Width(ByVal Value As Long)
    'If the width is increased, the image is destroyed
    If (Value > m_lWidth) Then
        'Apply new width and create new image of this size
        m_lWidth = Value
        Create m_lWidth, m_lHeight
    End If
End Property

'GET Height: Return height of image
'====================================================================================
Public Property Get Height() As Long
   Height = m_lHeight
End Property

'GET Height: Set height of image
'====================================================================================
Public Property Let Height(ByVal Value As Long)
    'If the height is increased, the image is destroyed
    If (Value > m_lHeight) Then
        m_lHeight = Value
        Create m_lWidth, m_lHeight
    End If
End Property

'GET hDC: Simply return the hDC of the memory image for API manipulation
'====================================================================================
Public Property Get hDC() As Long
   hDC = m_hDC
End Property

'=====================================================================================
'CreateFromPicture: Load an image into this class
'=====================================================================================
Public Sub CreateFromPicture(ByRef sPic As Object, Optional ByVal Chroma As Long = -1)
    Dim tB As Bitmap                    'The bitmap holder that will get the image
    Dim lhDCC As Long, lhDC As Long
    Dim lhBmpOld As Long
    
    'Retrieve image height/width
    GetObjectAPI sPic.handle, Len(tB), tB
    Create tB.bmWidth, tB.bmHeight, Chroma
    'Create a blank hDC
    lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    lhDC = CreateCompatibleDC(lhDCC)
    'If there's currently an image, remember it
    lhBmpOld = SelectObject(lhDC, sPic.handle)
    'Paint the new image over
    BitBlt m_hDC, 0, 0, tB.bmWidth, tB.bmHeight, lhDC, 0, 0, vbSrcCopy
    'Apply the hDC to the new image
    SelectObject lhDC, lhBmpOld
    
    'Cleanup the hdc's created for transferring
    DeleteDC lhDC
    DeleteDC lhDCC
End Sub

'=====================================================================================
'Create: Create a memory bitmap
'=====================================================================================
Public Function Create(ByVal Width As Long, ByVal Height As Long, Optional ByVal Chroma As Long = -1)
    Dim lhDCC As Long
    
    'Clear anything currently in memory
    p_Destroy
    'create hDC to be used
    lhDCC = CreateDC("DISPLAY", "", "", ByVal 0&)
    'If there wasn't an error in doing that
    If Not (lhDCC = 0) Then
        'create empty hDC
        m_hDC = CreateCompatibleDC(lhDCC)
        If Not (m_hDC = 0) Then
            'Create Bitmap from that DC
            m_hBMP = CreateCompatibleBitmap(lhDCC, Width, Height)
            If Not (m_hBMP = 0) Then
                'Retrieve reference to current image
                m_hBmpOld = SelectObject(m_hDC, m_hBMP)
                If Not (m_hBmpOld = 0) Then
                    'Apply width and height
                    m_lWidth = Width
                    m_lHeight = Height
                    'Apply chroma colour
                    Me.ChromaColour = Chroma
                    'Cleanup
                    DeleteDC lhDCC
                    Exit Function
                End If
            End If
        End If
        'Cleanup
        DeleteDC lhDCC
        'remove all properties if the function failed
        p_Destroy
    End If
End Function

'====================================================================================
'Draw
'====================================================================================
Public Function Draw(ByVal DesthDC, ByVal DestLeft As Long, ByVal DestTop As Long)
    'Is the image transparent?
    If Me.ChromaColour > -1 Then
        'Draw with chroma colour keyed out
        DrawTransparent DesthDC, DestLeft, DestTop, m_lWidth, m_lHeight, m_hDC, 0, 0, m_lWidth, m_lHeight, Me.ChromaColour
    Else
        'Draw normally
        BitBlt DesthDC, DestLeft, DestTop, m_lWidth, m_lHeight, m_hDC, 0, 0, vbSrcCopy
    End If
End Function

'====================================================================================
'DrawEx
'====================================================================================
Public Function DrawEx(ByVal DesthDC, ByVal DestLeft As Long, ByVal DestTop As Long, ByVal DestWidth As Long, ByVal DestHeight As Long, ByVal SrcLeft As Long, ByVal SrcTop As Long)
    'Is the image transparent?
    If Me.ChromaColour > -1 Then
        'Draw with chroma colour keyed out
        DrawTransparent DesthDC, DestLeft, DestTop, DestWidth, DestHeight, m_hDC, SrcLeft, SrcTop, DestWidth, DestHeight, Me.ChromaColour
    Else
        'Draw normally
        BitBlt DesthDC, DestLeft, DestTop, DestWidth, DestHeight, m_hDC, SrcLeft, SrcTop, vbSrcCopy
    End If
End Function

'====================================================================================
'Stretch
'====================================================================================
Public Function Stretch(ByVal DesthDC As Long, ByVal DestLeft As Long, ByVal DestTop As Long, ByVal DestWidth As Long, ByVal DestHeight As Long)
    StretchBlt DesthDC, DestLeft, DestTop, DestWidth, DestHeight, m_hDC, 0, 0, m_lWidth, m_lHeight, vbSrcCopy
End Function

'====================================================================================
'StretchEx
'====================================================================================
Public Function StretchEx(ByVal DesthDC As Long, ByVal DestLeft As Long, ByVal DestTop As Long, ByVal DestWidth As Long, ByVal DestHeight As Long, ByVal SrcLeft As Long, ByVal SrcTop As Long, ByVal srcWidth As Long, ByVal srcHeight As Long)
    StretchBlt DesthDC, DestLeft, DestTop, DestWidth, DestHeight, m_hDC, SrcLeft, SrcTop, srcWidth, srcHeight, vbSrcCopy
End Function

'=====================================================================================
'PRIVATE Destory: safely remove the memory image and free it's memory
'=====================================================================================
Private Sub p_Destroy()
    'If the previous image in use still exists switch back to it
    If Not m_hBmpOld = 0 Then
        SelectObject m_hDC, m_hBmpOld
        m_hBmpOld = 0
    End If
    'If the current picture isn't already destoryed, do so know
    If Not m_hBMP = 0 Then
        DeleteObject m_hBMP
        m_hBMP = 0
    End If
    'Clear up the system hDC reference to the image
    If Not m_hDC = 0 Then
        DeleteDC m_hDC
        m_hDC = 0
    End If
    'Reset these class properties
    m_lWidth = 0
    m_lHeight = 0
End Sub

'=====================================================================================
'CLASS Terminate - Cleanup on unload
'=====================================================================================
Private Sub Class_Terminate()
   p_Destroy
End Sub

'=== END ==========================================================================
'This work is licenced under the Creative Commons Attribution 2.5 License
